home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / DBASE_UT / TPDB335 / TPDB.PAS < prev    next >
Pascal/Delphi Source File  |  1993-11-26  |  50KB  |  1,831 lines
  1. {$A+,B-,D+,E+,F+,I+,L+,N-,O+,R-,S+,V-}
  2. {$M 16384,0,655360}
  3.  
  4. unit TPDB;
  5.  
  6. {This version is Version 3.35 November, 1993}
  7.  
  8.                            (***********************************)
  9.                            (*               TPDB              *)
  10.                            (***********************************)
  11.                            (*         Object -Oriented        *)
  12.                            (*    Borland/Turbo Pascal Units   *)
  13.                            (*    for Accessing dBASE III      *)
  14.                            (*             files.              *)
  15.                            (*      Copyright 1988 - 1993      *)
  16.                            (*          Brian Corll            *)
  17.                            (*       All Rights Reserved       *)
  18.                            (***********************************)
  19.                            (*            FREEWARE             *)
  20.                            (***********************************)
  21.                            (*     dBASE is a registered       *)
  22.                            (* trademark of Borland Int. Inc.  *)
  23.                            (*   Version 3.35  November, 1993  *)
  24.                            (***********************************)
  25.                            (*   Portions Copyright 1984,1991  *)
  26.                            (*    Borland International Corp.  *)
  27.                            (***********************************)
  28.  
  29.  
  30.  
  31.  
  32. interface
  33.  
  34. uses
  35.     {$IFDEF WINDOWS}
  36.     WinCrt,
  37.     WinDos,
  38.     {$ELSE}
  39.     Crt, Dos,
  40.     {$ENDIF}
  41.     TPDBINDX, TPDBDate, TPDBScrn, TPDBStr;
  42.  
  43.  
  44. (******************************)
  45. (*      Global VARiables      *)
  46. (******************************)
  47.  
  48. const
  49.  
  50. (**************************************************************************)
  51.     MaxInds = 10;                                           {Maximum number of indexes per file.  Change this as needed.}
  52. (**************************************************************************)
  53.  
  54.     AutoWrap: boolean = False;
  55.     CursorDown = ^X;
  56.     CursorEND = ^F;
  57.     CursorHome = ^A;
  58.     CursorLeft = ^S;
  59.     CursorRight = ^D;
  60.     CursorUp = ^E;
  61.     DelKey = ^G;
  62.     Escape = ^[;
  63.  
  64.     ExtKey: boolean = False;
  65.     Filler: char = #32;
  66.     MaxLong = 2147483647;
  67.     MaxReal = 3.4E37;
  68.     MinLong = - 2147483647;
  69.     MinReal = 1.5E-45;
  70.     NoDuplicates = 0;
  71.     Duplicates = 1;
  72.     PageDown = ^C;
  73.     PageUp = ^R;
  74.     Return = ^M;
  75.     TabKey = #9;
  76.     UpperCase: boolean = False;
  77.  
  78. {Date format constants}
  79. {Used by SetDateFormat procedure}
  80.     French = 1;                                             {dd/mm/yy}
  81.     German = 2;                                             {dd.mm.yy}
  82.     Italian = 3;                                            {dd-mm-yy}
  83.     American = 4;                                           {mm/dd/yy}
  84.     British = 5;                                            {dd/mm/yy}
  85.     Ansi = 99;                                              {yy.mm.dd}
  86.  
  87.  
  88.  
  89. type
  90.     Str2 = string [2];
  91.     Str4 = string [4];
  92.     Str5 = string [5];
  93.     Str6 = string [6];
  94.     Str8 = string [8];
  95.     Str10 = string [10];
  96.     Str15 = string [15];
  97.     Str20 = string [20];
  98.     Str30 = string [30];
  99.     Str60 = string [60];
  100.     Str80 = string [80];
  101.     Str132 = string [132];
  102.     Str254 = string [254];
  103.     CharSet = set of char;
  104.     ByteSet = set of byte;
  105.  
  106.     FileName = string [66];
  107.  
  108.     DBHeader = record
  109.         DBType: byte;
  110.         Year: byte;
  111.         Month: byte;
  112.         Day: byte;
  113.         RecCount: longint;
  114.         Location: integer;
  115.         RecordLen: integer;
  116.         RESERVED: array [1..20] of byte;
  117.         Terminator: char;
  118.     end;
  119.  
  120.     DBField = record
  121.         FieldName: array [1..11] of char;
  122.         FieldType: byte;
  123.         FieldAddress: longint;
  124.         FieldLen: byte;
  125.         FieldDec: byte;
  126.         RESERVED: array [1..14] of char;
  127.     end;
  128.  
  129.     HeadPtr = ^DBHeader;
  130.     PosPtr = ^DBEditArray;
  131.     FieldPtr = ^FieldArray;
  132.     DBEditArray = array [1..2, 1..128] of integer;
  133.     FieldArray = array [1..128] of DBField;
  134.     DBIndex = record
  135.         Ndx: IndexFile;
  136.         NdxID: byte;
  137.         NdxName: FileName;
  138.         Open: boolean;
  139.     end;
  140.  
  141.     NdxArray = array [1..MaxInds] of DBIndex;
  142.     NdxPtr = ^NdxArray;
  143.  
  144. (*****************************************************************************)
  145. (*             Database File Object Declaration                              *)
  146. (*****************************************************************************)
  147.  
  148.     DataObject = ^DBF;
  149.  
  150.     DBF = object
  151.         DBFName: FileName;
  152.         DBFile: file;
  153.         Header: HeadPtr;
  154.         Fields: FieldPtr;
  155.         DBFOpen: boolean;
  156.         IndsOpen: boolean;
  157.         Indexes: NdxPtr;
  158.         CurrNdx : Byte;
  159.         DBRecord:Pointer;
  160.         DBRecNum: longint;
  161.         TotalRecs: longint;
  162.         NumFields: byte;
  163.         MAlloc: boolean;
  164.         Start, Stop: integer;
  165.         function Add(Field1, Field2: byte): string;
  166.         procedure AddDBKey(NdxID: byte; KeyStr: DBKey);
  167.         procedure AddDBRec;
  168.         function Allocated: boolean;
  169.         procedure AppendBlank;
  170.         procedure BailOut;
  171.         function BinSearch(FieldNo: byte; Position: integer; SearchKey: DBKey): longint;
  172.         function BOF: boolean;
  173.         procedure CloseDBIndex(NdxID: byte);
  174.         procedure DBReset;
  175.         procedure DelDBKey(KeyStr: DBKey; NdxID: byte);
  176.         function Deleted: boolean;
  177.         procedure Display;
  178.         function Divide(Field1, Field2: byte): string;
  179.         destructor Done;
  180.         function DBEOF: boolean;
  181.         function Field(FNo: byte): string;
  182.         procedure FillRecs(NumRecs: longint);
  183.         procedure Find(NdxID: byte; SearchStr: string);
  184.         procedure FlushDB;
  185.         procedure Get(FNo, X, Y: byte);
  186.         procedure GetDBRec(RecordNumber: longint);
  187.         function GetField(RecordNo: longint; FNo: byte): string;
  188.         procedure GoBottom;
  189.         procedure GoTop;
  190.         function IIF(BoolVAR: boolean; IfTRUE, IfFALSE: string): string;
  191.         procedure IndexOn(NdxID: byte; NdxName: FileName; NdxField: byte; DupFlag: byte);
  192.         function IndsAreOpen: boolean;
  193.         constructor Init(DBName: FileName);
  194.         function Locate(FieldNo: byte; SearchStr: string): boolean;
  195.         procedure LookUp(SearchStr: string; NdxID: byte);
  196.         procedure MakeDBIndex(NdxID: byte; DBIndexName: FileName; KeyLen, Status: integer);
  197.         procedure Mark;
  198.         function Mul(Field1, Field2: byte): string;
  199.         procedure NextDBKey(NdxID: byte; KeyStr: DBKey);
  200.         procedure NewDBRec;
  201.         procedure NextRec;
  202.         procedure OpenDBIndex(NdxID: byte; DBIndexName: FileName; KeyLen, Status: integer);
  203.         procedure Pack;
  204.         procedure PrevDBKey(NdxID: byte; KeyStr: DBKey);
  205.         procedure PrevRec;
  206.         procedure PutDBRec(RecordNumber: longint);
  207.         procedure ReadDBHeader;
  208.         procedure Recall;
  209.         function RecCount: longint;
  210.         function RecNo: longint;
  211.         procedure Repl(FNo: byte; InStr: string);
  212.         procedure ReplEach(FNo: byte; InStr: string);
  213.         procedure Save;
  214.         procedure Say(FNo, Row, Col: byte);
  215.         procedure SetIndexTo(NdxID : Byte);
  216.         procedure ShowStatus;
  217.         procedure Skip(NumRecs : Longint);
  218.         function Sub(Field1, Field2: byte): string;
  219.         function Sum(FNo: byte): real;
  220.         procedure WriteDBHeader;
  221.         procedure Zap;
  222.     end;
  223.  
  224. (****************************************************************************)
  225. (*          END Object Declaration                                          *)
  226. (****************************************************************************)
  227.  
  228. const
  229.  
  230.     Up: CharSet = [CursorUp];
  231.     Down: CharSet = [CursorDown, Return];
  232.     Next: CharSet = [Escape];
  233.  
  234. var
  235.     FilesOpen: byte;
  236.     UCKey: boolean;
  237.     ErrCode: integer;
  238.     Found: boolean;
  239.     Ch, BC: char;
  240.     Normal, Reverse: byte;
  241.     Decimals: byte;
  242.     TempFile: file;
  243.     K: byte;
  244.     NumLen: byte;
  245.     Y, M, D, DW: word;
  246.     FromPack: boolean;
  247.     DateFormat: byte;
  248.  
  249. (**********************************)
  250. (*   PROCEDUREs and FUNCTIONs     *)
  251. (**********************************)
  252.  
  253. procedure Beep;
  254. {Sound a couple of tones.}
  255.  
  256. function BoolToStr(Param: byte; IfTRUE, IfFALSE: char): string;
  257.  
  258.  
  259. procedure CheckScreen(var CurrPos: byte; BC: char; Up, Down: CharSet; Low, High: byte);
  260. {Used in full screen editing.}
  261.  
  262. procedure CopyFile(Source, Dest: FileName);
  263.  
  264. procedure FlashFill(Row, Col, Rows, Cols, Attr: byte; Ch: char);
  265. {Fill a region of the screen with a specified color and character.}
  266.  
  267. function GetBoolean(var Param: byte; IfTRUE, IfFALSE: char; X, Y: byte): char;
  268.  
  269. function GetByte(var Param: byte; LowLim, UpLim, Len, X, Y: byte): char;
  270.  
  271. function GetInteger(var Param: integer; LowLim, UpLim: integer; Len, X, Y: byte): char;
  272. {Input an integer.}
  273.  
  274. function GetLongInt(var Param: longint; LowLim, UpLim: longint; Len, X, Y: byte): char;
  275. {Input a long integer.}
  276.  
  277. function GetReal(var Param: real; LowLim, UpLim: real; Len, X, Y: word): char;
  278. {Input a real number.}
  279.  
  280. function GetString(var Param: string; Len, X, Y: byte): char;
  281. {Input a string.}
  282.  
  283. function Input(var S: string; Term: CharSet; L, X, Y: byte; var BC: char): string;
  284.  
  285. function IntToStr(Number: longint): string;
  286.  
  287. function Max(N1, N2: integer): integer;
  288.  
  289. function Min(N1, N2: integer): integer;
  290.  
  291. procedure Prompt(Row, Col: byte; PromptStr: Str80);
  292. {Display a prompt at a specified row and column.}
  293.  
  294. function ReadChar: char;
  295.  
  296. procedure ReadKB(var ExtKey: boolean; var Ch: char);
  297.  
  298. function RealToStr(Number: real): string;
  299.  
  300. procedure SetDateFormat(Format: byte);
  301.  
  302. procedure SetDBColor(FG, BG: byte);
  303. {Set initial foreground and background colors.}
  304.  
  305. procedure Wait;
  306. {Wait for a key press and display a message.}
  307.  
  308.  
  309. implementation
  310.  
  311. function DBF.Add(Field1, Field2: byte): string;             (* Adds two fields and returns the string of the sum. *)
  312.  
  313. var
  314.     T1, T2, T3: string;
  315.     A1, A2, A3: real;
  316.     ErrCode: integer;
  317.  
  318. begin
  319.     T1 := RTrim(Field(Field1));
  320.     T2 := RTrim(Field(Field2));
  321.     Val(T1, A1, ErrCode);
  322.     Val(T2, A2, ErrCode);
  323.     A3 := A1 + A2;
  324.     Str(A3: Max(Fields^[Field1].FieldLen, Fields^[Field2].FieldLen): Max(Fields^[Field1].FieldDec, Fields^[Field2].FieldDec),
  325.             T3);
  326.     Add := LTrim(T3);
  327. end;
  328.  
  329. procedure DBF.AddDBKey(NdxID: byte; KeyStr: DBKey);
  330.  
  331. begin
  332.     if UCKey then
  333.         KeyStr := Upper(KeyStr);
  334.     AddKey(Indexes^[NdxID].Ndx, DBRecNum, KeyStr);
  335. end;
  336.  
  337. procedure DBF.AddDBRec;                                     {Add new record, no index open.}
  338.  
  339. var
  340.     RecordNumber: longint;
  341.  
  342. begin
  343.     TotalRecs := TotalRecs + 1;
  344.     RecordNumber := TotalRecs;
  345.     DBRecNum := RecordNumber;
  346.     RecordNumber := (RecordNumber - 1) * Header^.RecordLen + Header^.Location;
  347.     Seek(DBFile, RecordNumber);
  348.     BlockWrite(DBFile, DBRecord^, Header^.RecordLen, ErrCode);
  349.     Dispose(DBRecord);
  350.     DBRecord := nil;
  351. end;
  352.  
  353. function DBF.Allocated: boolean;
  354.  
  355. begin
  356.     Allocated := (DBRecord <> nil);
  357. end;
  358.  
  359. procedure DBF.AppendBlank;
  360.  
  361. var
  362.     RecordNumber: longint;
  363.  
  364. begin
  365.     NewDBRec;
  366.     TotalRecs := TotalRecs + 1;
  367.     RecordNumber := TotalRecs;
  368.     DBRecNum := RecordNumber;
  369.     RecordNumber := (RecordNumber - 1) * Header^.RecordLen + Header^.Location;
  370.     Seek(DBFile, RecordNumber);
  371.     BlockWrite(DBFile, DBRecord^, Header^.RecordLen, ErrCode);
  372. end;
  373.  
  374.  
  375. procedure DBF.BailOut;
  376.  
  377. var
  378.     Message: string [80];
  379.     Number: string;
  380.     ID: byte;
  381.  
  382. begin
  383.     GotOne := True;
  384.     for ID := 1 to MaxInds do
  385.         if Indexes^[ID].Open then
  386.             CloseDBIndex(ID);
  387.     IndsOpen := False;
  388.     SetDBColor(White, Blue);
  389.     ClrScr;
  390.     case TPDBErr of
  391.         1: Message := 'Invalid DOS FUNCTION code !';
  392.         2: Message := 'File not found ! ' + IIF(Length(RTrim(LTrim(TErrorName))) <> 0, ' -- > ' + Upper(TErrorName), '');
  393.         3: Message := 'Path not found !';
  394.         4: Message := 'Too many open files !';
  395.         5: Message := 'File access denied !';
  396.         6: Message := 'Invalid file handle !';
  397.         8: Message := 'Not enough memory !';
  398.         9: Message := 'Too many open indexes !';
  399.         12: Message := 'Invalid file access code !';
  400.         15: Message := 'Invalid drive number !';
  401.         16: Message := 'Cannot remove current directory !';
  402.         17: Message := 'Cannot rename across drives !';
  403.         100: Message := 'Disk read error !';
  404.         101: Message := 'Disk write error !';
  405.         102: Message := 'File not assigned !';
  406.         103: Message := 'File not open !';
  407.         104: Message := 'File not open for input !';
  408.         105: Message := 'File not open for output !';
  409.         106: Message := 'Invalid numeric format !';
  410.         200: Message := 'Division by zero !';
  411.         201: Message := 'Range check error !';
  412.         202: Message := 'Stack overflow error !';
  413.         203: Message := 'Heap overflow error !';
  414.         204: Message := 'Invalid pointer operation !';
  415.         1000: Message := 'Record size is greater than 4000 chars !';
  416.         1002: Message := 'Specified Index Key Length is greater than 254 chars !';
  417.         1003: Message := 'Invalid DBF File structure !';
  418.         1004: Message := 'Index File created with different key size !';
  419.         1005: Message := 'Not enough memory for index page stack !';
  420.     end;
  421.     Beep;
  422.     Beep;
  423.     FlashC(8, White + BlueBG, 'TPDB Version 3.24');
  424.     FlashC(10, Yellow + BlueBG, 'ERROR !');
  425.     FlashC(12, White + RedBG, Message);
  426.     CursorOff;
  427.     FlashC(14, LightRed + BlueBG, 'Press any key to halt program....');
  428.     FlashC(16, LightCyan + BlueBG, 'Copyright 1989 Brian Corll');
  429.     repeat
  430.     until KeyPressed;
  431.     TErrorName := '';
  432.     TPDBErr := 0;
  433.     SetDBColor(White, Black);
  434.     ClrScr;
  435.     Halt(1);
  436. end;
  437.  
  438. procedure Beep;
  439.  
  440. begin
  441.     Sound(1500);
  442.     Delay(50);
  443.     Sound(1000);
  444.     Delay(50);
  445.     NoSound;
  446. end;
  447.  
  448. function DBF.BinSearch(FieldNo: byte; Position: integer; SearchKey: DBKey): longint;
  449. {Implements a binary search for sorted files of unique elements }
  450.  
  451. var
  452.     Width: integer;
  453.     J, Low, High, Result: longint;
  454.  
  455. begin
  456.     Width := Length(SearchKey);
  457.     if Width < 1 then
  458.         Exit;
  459.     Low := 1;
  460.     High := TotalRecs;
  461.     while High >= Low do begin
  462.         J := (Low + High) div 2;
  463.         GetDBRec(J);
  464.         if SearchKey < Copy(Field(FieldNo), Position, Width) then
  465.             High := J - 1
  466.         else if SearchKey > Copy(Field(FieldNo), Position, Width) then
  467.             Low := J + 1
  468.         else begin
  469.             BinSearch := J;
  470.             Exit
  471.         end
  472.     end;
  473.     BinSearch := 0;
  474. end;
  475.  
  476.  
  477. function DBF.BOF: boolean;
  478.  
  479. begin
  480.     if IndsAreOpen then
  481.         BOF := not OK
  482.     else if DBRecNum = 1 then
  483.         BOF := True
  484.     else
  485.         BOF := False;
  486. end;
  487.  
  488. function BoolToStr(Param: byte; IfTRUE, IfFALSE: char): string;
  489.  
  490. var
  491.     Temp: string;
  492.  
  493. begin
  494.     case Param of
  495.         0: Temp := Filler;
  496.         1: Temp := IfTRUE;
  497.         2: Temp := IfFALSE;
  498.     end;
  499.     BoolToStr := Temp;
  500. end;
  501.  
  502.  
  503.  
  504. procedure CheckScreen(var CurrPos: byte; BC: char; Up, Down: CharSet; Low, High: byte);
  505.  
  506. begin
  507.     if (BC in Down) then
  508.         if CurrPos = High then
  509.             CurrPos := Low
  510.         else
  511.             Inc(CurrPos)
  512.     else if (BC in Up) then
  513.         if CurrPos = Low then
  514.             CurrPos := High
  515.         else
  516.             Dec(CurrPos)
  517. end;
  518.  
  519.  
  520. destructor DBF.Done;
  521.  
  522. var
  523.     EOFMarker: byte;
  524.     Z: byte;
  525.  
  526. begin
  527.     WriteDBHeader;
  528.     EOFMarker := $1A;
  529.     Seek(DBFile, Header^.Location + (Header^.RecCount * Header^.RecordLen));
  530.     BlockWrite(DBFile, EOFMarker, 1);
  531.     Close(DBFile);
  532.     Dec(FilesOpen);
  533.     if not MAlloc then begin
  534.         Dispose(Header);
  535.         Dispose(Fields);
  536.     end;
  537.     if Allocated then begin
  538.         Dispose(DBRecord);
  539.         DBRecord := nil;
  540.     end;
  541.     DBFOpen := False;
  542.     for Z := 1 to MaxInds do begin
  543.         if Indexes^[Z].Open then begin
  544.             CloseDBIndex(Z);
  545.             Indexes^[Z].Open := False;
  546.         end;
  547.     end;
  548.     if FromPack then
  549.         FromPack := False
  550.     else
  551.         Dispose(Indexes);
  552. end;
  553.  
  554. procedure DBF.CloseDBIndex(NdxID: byte);
  555.  
  556. begin
  557.     if Indexes^[NdxID].Open then begin
  558.         CloseIndex(Indexes^[NdxID].Ndx);
  559.         Indexes^[NdxID].Open := False;
  560.     end;
  561.     Dec(FilesOpen);
  562. end;
  563.  
  564. procedure CopyFile(Source, Dest: FileName);
  565. { Copies a .DBF file to another .DBF file }
  566.  
  567. type
  568.     FileBuffer = array [1..65521] of byte;
  569.  
  570. var
  571.     Buffer:^byte;
  572.     InFile, OutFile: file;
  573.     ErrorCode, BlocksRead, BlocksWritten: word;
  574.     Time: longint;
  575.     BufferSize: word;
  576.  
  577. begin
  578.     BufferSize := SizeOf(FileBuffer);
  579.     if (BufferSize > MaxAvail) then
  580.         BufferSize := MaxAvail;
  581.     GetMem(Buffer, BufferSize);
  582.     Assign(InFile, Source);
  583.     Reset(InFile, 1);
  584.     ErrorCode := IOResult;
  585.     GetFTime(InFile, Time);
  586.     if ErrorCode = 0 then begin
  587.         Assign(OutFile, Dest);
  588.         Rewrite(OutFile, 1);
  589.         ErrorCode := IOResult;
  590.         if ErrorCode = 0 then begin
  591.             repeat
  592.                 BlockRead(InFile, Buffer^, BufferSize, BlocksRead);
  593.                 BlockWrite(OutFile, Buffer^, BlocksRead, BlocksWritten);
  594.                 if BlocksWritten < BlocksRead then
  595.                     ErrorCode := 81;
  596.             until ((ErrorCode <> 0) or (BlocksRead < BufferSize));
  597.             SetFTime(OutFile, Time);
  598.             Close(OutFile);
  599.             if ErrorCode <> 0 then
  600.                 Erase(OutFile);
  601.         end;
  602.         Close(InFile);
  603.     end;
  604.     FreeMem(Buffer, BufferSize);
  605. end;                                                        { CopyFile }
  606.  
  607.  
  608. procedure DBF.DBReset;                                      {Reset dBASE file.}
  609.  
  610. begin                                                       {$I-}
  611.     Reset(DBFile, 1);                                       {$I+}
  612.     if TPDBErr = 0 then
  613.         TPDBErr := IOResult;
  614.     if (TPDBErr <> 0) and (not GotOne) then begin
  615.         TErrorName := DBFName;
  616.         BailOut;
  617.     end;
  618. end;
  619.  
  620. procedure DBF.DelDBKey(KeyStr: DBKey; NdxID: byte);
  621.  
  622. begin
  623.     if UCKey then
  624.         KeyStr := Upper(KeyStr);
  625.     DeleteKey(Indexes^[NdxID].Ndx, DBRecNum, KeyStr);
  626. end;
  627.  
  628. function DBF.Deleted: boolean;
  629.  
  630. begin
  631.     if Mem[Seg(DBRecord^):Ofs(DBRecord^)+1] = $2A then
  632.         Deleted := True
  633.     else
  634.         Deleted := False;
  635. end;
  636.  
  637. procedure DBF.Display;
  638.  
  639. var
  640.     FNo: byte;
  641.     K: integer;
  642.  
  643. begin
  644.     ClrScr;
  645.     for FNo := 1 to NumFields do begin
  646.         for K := 1 to 11 do
  647.             Write(Fields^[FNo].FieldName[K]);
  648.         Write(': ');
  649.         if Chr(Ord(Fields^[FNo].FieldType)) = 'D' then
  650.             Write(FormDate(Field(FNo)))
  651.         else
  652.             Write(Field(FNo));
  653.         Writeln;
  654.         if FNo mod 23 = 0 then begin
  655.             Wait;
  656.             ClrScr;
  657.         end;
  658.     end;
  659. end;
  660.  
  661. function DBF.Divide(Field1, Field2: byte): string;          (* Divide field1 BY field 2 *)
  662.  
  663. var
  664.     T1, T2, T3: string;
  665.     D1, D2, D3: real;
  666.  
  667. begin
  668.     T1 := RTrim(Field(Field1));
  669.     T2 := RTrim(Field(Field2));
  670.     Val(T1, D1, ErrCode);
  671.     Val(T2, D2, ErrCode);
  672.     D3 := D1 / D2;
  673.     Str(D3: Max(Fields^[Field1].FieldLen, Fields^[Field2].FieldLen): Max(Fields^[Field1].FieldDec, Fields^[Field2].FieldDec),
  674.             T3);
  675.     Divide := LTrim(T3);
  676. end;
  677.  
  678. function DBF.DBEOF: boolean;
  679.  
  680. begin
  681.     if IndsAreOpen and (CurrNdx > 0) then
  682.         DBEOF := not OK
  683.     else
  684.         DBEOF := (DBRecNum > TotalRecs);
  685. end;
  686.  
  687. function DBF.Field(FNo: byte): string;
  688.  
  689. var
  690.     Temp: string;
  691.  
  692. begin
  693.     Temp[0] := Chr(Ord(Fields^[FNo].FieldLen));
  694.     Move(Mem[Seg(DBRecord^):Ofs(DBRecord^)+Fields^[FNo].FieldAddress], Temp[1], Fields^[FNo].FieldLen);
  695.     Temp := PadR(Temp, Fields^[FNo].FieldLen);
  696.     Field := Temp;
  697. end;
  698.  
  699. procedure DBF.FillRecs(NumRecs: longint);
  700.  
  701. var
  702.     J: longint;
  703.  
  704. begin
  705.     if TotalRecs > 0 then
  706.         GoBottom;
  707.     for J := 1 to NumRecs do begin
  708.         NewDBRec;
  709.         AddDBRec;
  710.     end;
  711. end;
  712.  
  713. procedure DBF.Find(NdxID: byte; SearchStr: string);
  714.  
  715. begin
  716.     FindKey(Indexes^[NdxID].Ndx, DBRecNum, SearchStr);
  717.     if OK then begin
  718.         GetDBRec(DBRecNum);
  719.         Found := True;
  720.     end else
  721.         Found := False;
  722. end;
  723.  
  724. procedure FlashFill(Row, Col, Rows, Cols, Attr: byte; Ch: char);
  725.  
  726. var
  727.     Z: byte;
  728.     Temp: string;
  729.  
  730. begin
  731.     Temp := Replicate(Ch, Cols);
  732.     for Z := Row to Row + Rows - 1 do
  733.         Flash(Z, Col, Attr, Temp);
  734. end;
  735.  
  736.  
  737.  
  738. procedure DBF.FlushDB;
  739.  
  740. begin
  741.     MAlloc := True;
  742.     Done;
  743.     MAlloc := False;
  744.     DBReset;
  745. end;
  746.  
  747. procedure DBF.Get(FNo, X, Y: byte);
  748.  
  749. var
  750.     TempStr1: string;
  751.  
  752. procedure Character;
  753.  
  754. begin
  755.     TempStr1 := Field(FNo);
  756.     BC := GetString(TempStr1, Fields^[FNo].FieldLen, Y, X);
  757.     Repl(FNo, TempStr1);
  758.     TempStr1 := PadR(TempStr1, Fields^[FNo].FieldLen);
  759.     Flash(X, Y, Normal, Tempstr1);
  760. end;                                                        {PROCEDURE Character}
  761.  
  762. procedure Numeric;
  763.  
  764. var
  765.     NumLen: byte;
  766.     TempInt: longint;
  767.     TempReal: real;
  768.     RealStr, IntStr: string;
  769.  
  770. begin
  771.     NumLen := Fields^[FNo].FieldLen;
  772.     Decimals := Fields^[FNo].FieldDec;                      {If field is a real number}
  773.     if Decimals > 0 then begin
  774.         RealStr := '';
  775.         TempReal := 0;
  776.         RealStr := Field(FNo);
  777.         Val(RealStr, TempReal, ErrCode);
  778.         BC := GetReal(TempReal, MinReal, MaxReal, NumLen, Y, X);
  779.         Str(TempReal: NumLen: Decimals, RealStr);
  780.         Repl(FNo, RealStr);
  781.         Flash(X, Y, Normal, RealStr);
  782.     end else                                                {Otherwise, it's an integer value}
  783.             begin
  784.         IntStr := '';
  785.         TempInt := 0;
  786.         IntStr := Field(FNo);
  787.         Val(IntStr, TempInt, ErrCode);
  788.         BC := GetLongInt(TempInt, MinLong, MaxLong, NumLen, Y, X);
  789.         Str(TempInt: NumLen, IntStr);
  790.         Repl(FNo, IntStr);
  791.         Flash(X, Y, Normal, IntStr);
  792.     end;
  793. end;                                                        {PROCEDURE Numeric}
  794.  
  795. procedure Dates;
  796.  
  797. var
  798.     TempDate, TmpDat2: string [8];
  799.     MM, DD, DC: byte;
  800.     YY, GG: integer;
  801.     TM, TD, TY, Month, Day: string [2];
  802.     Year: string [4];
  803.  
  804. begin
  805.     TempDate := '';
  806.     TempDate := Field(FNo);
  807.     repeat
  808.         Year := Copy(TempDate, 1, 4);
  809.         Month := Copy(TempDate, 5, 2);
  810.         Day := Copy(TempDate, 7, 2);
  811.         Val(Year, YY, ErrCode);
  812.         Val(Month, MM, ErrCode);
  813.         Val(Day, DD, ErrCode);
  814.         if YY >= 1900 then
  815.             YY := YY - 1900;
  816.         case DateFormat of
  817.             American: begin
  818.                 BC := GetByte(MM, 0, 12, 2, Y, X);
  819.                 BC := GetByte(DD, 0, 31, 2, Y + 3, X);
  820.                 BC := GetInteger(YY, 0, 99, 2, Y + 6, X);
  821.             end;
  822.             French: begin
  823.                 BC := GetByte(DD, 0, 31, 2, Y, X);
  824.                 BC := GetByte(MM, 0, 12, 2, Y + 3, X);
  825.                 BC := GetInteger(YY, 0, 99, 2, Y + 6, X);
  826.             end;
  827.             Italian: begin
  828.                 BC := GetByte(DD, 0, 31, 2, Y, X);
  829.                 BC := GetByte(MM, 0, 12, 2, Y + 3, X);
  830.                 BC := GetInteger(YY, 0, 99, 2, Y + 6, X);
  831.             end;
  832.             German: begin
  833.                 BC := GetByte(DD, 0, 31, 2, Y, X);
  834.                 BC := GetByte(MM, 0, 12, 2, Y + 3, X);
  835.                 BC := GetInteger(YY, 0, 99, 2, Y + 6, X);
  836.             end;
  837.             Ansi: begin
  838.                 BC := GetInteger(YY, 0, 99, 2, Y, X);
  839.                 BC := GetByte(MM, 0, 12, 2, Y + 3, X);
  840.                 BC := GetByte(DD, 0, 31, 2, Y + 6, X);
  841.             end;
  842.             British: begin
  843.                 BC := GetByte(DD, 0, 31, 2, Y, X);
  844.                 BC := GetByte(MM, 0, 12, 2, Y + 3, X);
  845.                 BC := GetInteger(YY, 0, 99, 2, Y + 6, X);
  846.             end;
  847.         end;
  848.         Str(MM, Month);
  849.         Str(DD, Day);
  850.         YY := YY + 1900;
  851.         Str(YY: 4, Year);
  852.         if DD < 10 then
  853.             Day := '0' + Day;
  854.         if MM < 10 then
  855.             Month := '0' + Month;
  856.         TempDate := Year + Month + Day;
  857.         if not ValidDate(TempDate) then
  858.             Beep;
  859.         case DateFormat of
  860.             American: begin
  861.                 TmpDat2 := Copy(TempDate, 5, 2) + '/' + Copy(TempDate, 7, 2) + '/' + Copy(TempDate, 3, 2);
  862.             end;
  863.             French: begin
  864.                 TmpDat2 := Copy(TempDate, 7, 2) + '/' + Copy(TempDate, 5, 2) + '/' + Copy(TempDate, 3, 2)
  865.             end;
  866.             Italian: begin
  867.                 TmpDat2 := Copy(TempDate, 7, 2) + '-' + Copy(TempDate, 5, 2) + '-' + Copy(TempDate, 3, 2)
  868.             end;
  869.             German: begin
  870.                 TmpDat2 := Copy(TempDate, 7, 2) + '.' + Copy(TempDate, 5, 2) + '.' + Copy(TempDate, 3, 2)
  871.             end;
  872.             Ansi: begin
  873.                 TmpDat2 := Copy(TempDate, 3, 2) + '.' + Copy(TempDate, 5, 2) + '.' + Copy(TempDate, 7, 2)
  874.             end;
  875.             British: begin
  876.                 TmpDat2 := Copy(TempDate, 7, 2) + '/' + Copy(TempDate, 5, 2) + '/' + Copy(TempDate, 3, 2)
  877.             end;
  878.  
  879.         end;
  880.         Flash(X, Y, Normal, TmpDat2);
  881.     until ValidDate(TempDate);
  882.     Repl(FNo, TempDate);
  883. end;                                                        {PROCEDURE Dates}
  884.  
  885. procedure Logical;
  886.  
  887. var
  888.     BoolVAR: byte;
  889.     TF: string [1];
  890.  
  891. begin
  892.     case Mem[Seg(DBRecord^):Ofs(DBRecord^)+Fields^[FNo].FieldAddress] of
  893.         Ord('Y'): BoolVAR := 1;
  894.         Ord('N'): BoolVAR := 2 else BoolVAR := 0;
  895.     end;
  896.     BC := GetBoolean(BoolVAR, 'Y', 'N', Y, X);
  897.     TF := BoolToStr(BoolVAR, 'Y', 'N');
  898.     Mem[Seg(DBRecord^):Ofs(DBRecord^)+Fields^[FNo].FieldAddress] := Ord(TF[1]);
  899.     Flash(X, Y, Normal, TF);
  900. end;
  901.  
  902. var
  903.     Z: byte;
  904.  
  905. begin                                                       {PROCEDURE Get}
  906.     case Chr(Ord(Fields^[FNo].FieldType)) of
  907.         'C': Character;
  908.         'L': Logical;
  909.         'N': Numeric;
  910.         'D': Dates;
  911.     end;
  912. end;                                                        {PROCEDURE Get}
  913.  
  914.  
  915. function GetBoolean(var Param: byte; IfTRUE, IfFALSE: char; X, Y: byte): char;
  916.  
  917. var
  918.     BC: char;
  919.     Temp: string;
  920.     Value: byte;
  921.  
  922. begin
  923.     Value := Param;
  924.     Temp := BoolToStr(Value, IfTRUE, IfFALSE);
  925.     UpperCase := True;
  926.     Temp := Input(Temp, [IfTRUE, IfFALSE], 1, X, Y, BC);
  927.     if Length(Temp) = 0 then begin
  928.         Param := 0;
  929.         Flash(Y, X, Normal, BoolToStr(Param, IfTRUE, IfFALSE));
  930.     end else begin
  931.         if Temp = Filler then
  932.             Param := 0;
  933.         if Temp = IfTRUE then
  934.             Param := 1;
  935.         if Temp = IfFALSE then
  936.             Param := 2;
  937.     end;
  938.     UpperCase := False;
  939.     GetBoolean := BC;
  940. end;
  941.  
  942. function GetByte(var Param: byte; LowLim, UpLim, Len, X, Y: byte): char;
  943.  
  944. var
  945.     BC: char;
  946.     WW, WL, WH: longint;
  947.  
  948. begin
  949.     WW := longint(Param);
  950.     WL := longint(LowLim);
  951.     WH := longint(UpLim);
  952.     BC := GetLongInt(WW, WL, WH, Len, X, Y);
  953.     Param := byte(WW);
  954.     GetByte := BC;
  955. end;
  956.  
  957. procedure DBF.GetDBRec(RecordNumber: longint);
  958.  
  959. begin
  960.     if not Allocated then begin
  961.         GetMem(DBRecord,Header^.RecordLen);
  962.     end else begin
  963.         FreeMem(DBRecord,Header^.RecordLen);
  964.         DBRecord := nil;
  965.         GetMem(DBRecord,Header^.RecordLen)
  966.     end;
  967.     DBRecNum := RecordNumber;
  968.     RecordNumber := (RecordNumber - 1) * Header^.RecordLen + Header^.Location;
  969.     Seek(DBFile, RecordNumber);
  970.     BlockRead(DBFile, DBRecord^, Header^.RecordLen, ErrCode);
  971. end;
  972.  
  973. function DBF.GetField(RecordNo: longint; FNo: byte): string;
  974.  
  975. type
  976.     FldArray = array [1..254] of char;
  977.  
  978. var
  979.     TempArray: FldArray;
  980.  
  981.     FldAddr, RecordNumber: longint;
  982.     Temp: string [254];
  983.     K: byte;
  984.  
  985. begin
  986.     if FNo = 1 then
  987.         FldAddr := 1
  988.     else begin
  989.         FldAddr := 1;
  990.         for K := 1 to FNo - 1 do
  991.             FldAddr := FldAddr + Fields^[K].FieldLen;
  992.     end;
  993.     RecordNumber := (RecordNo - 1) * Header^.RecordLen + Header^.Location + FldAddr;
  994.     Seek(DBFile, RecordNumber);
  995.     BlockRead(DBFile, TempArray, Fields^[FNo].FieldLen, ErrCode);
  996.     Temp := '';
  997.     for K := 1 to Fields^[FNo].FieldLen do
  998.         Temp := Temp + TempArray[K];
  999.     GetField := Temp;
  1000. end;
  1001.  
  1002.  
  1003. function GetInteger(var Param: integer; LowLim, UpLim: integer; Len, X, Y: byte): char;
  1004.  
  1005. var
  1006.     BC: char;
  1007.     WW, WL, WH: longint;
  1008.  
  1009. begin
  1010.     WW := longint(Param);
  1011.     WL := longint(LowLim);
  1012.     WH := longint(UpLim);
  1013.     BC := GetLongInt(WW, WL, WH, Len, X, Y);
  1014.     Param := integer(WW);
  1015.     GetInteger := BC;
  1016. end;
  1017.  
  1018. function GetLongInt(var Param: longint; LowLim, UpLim: longint; Len, X, Y: byte): char;
  1019.  
  1020. var
  1021.     Temp: string;
  1022.     P, Value: longint;
  1023.     I: integer;
  1024.     Err: boolean;
  1025.     BC: char;
  1026.  
  1027. begin
  1028.     repeat
  1029.         Err := False;
  1030.         Str(Param, Temp);
  1031.         Temp := Input(Temp, ['0'..'9'], Len, X, Y, BC);
  1032.         Val(Temp, P, I);
  1033.         if Length(Temp) = 0 then
  1034.             Value := 0
  1035.         else if I = 0 then
  1036.             Value := P
  1037.         else begin
  1038.             Value := Param;
  1039.             Beep;
  1040.             Err := True;
  1041.         end;
  1042.         if (not ((Value >= LowLim) and (Value <= UpLim))) then
  1043.             Beep;
  1044.     until (Value >= LowLim) and (Value <= UpLim) and (not (Err));
  1045.     Param := Value;
  1046.     GetLongInt := BC;
  1047. end;
  1048.  
  1049.  
  1050. function GetReal(var Param: real; LowLim, UpLim: real; Len, X, Y: word): char;
  1051.  
  1052. var
  1053.     Temp: string;
  1054.     P, Value: real;
  1055.     I: word;
  1056.     Err: boolean;
  1057.     BC: char;
  1058.  
  1059. begin
  1060.     repeat
  1061.         Err := False;
  1062.         Temp := RealToStr(Param);
  1063.         Temp := Input(Temp, ['0'..'9', '.', '-'], Len, X, Y, BC);
  1064.         Val(Temp, P, I);
  1065.         if Length(Temp) = 0 then
  1066.             Value := 0.0
  1067.         else if I = 0 then
  1068.             Value := P
  1069.         else begin
  1070.             Value := Param;
  1071.             Beep;
  1072.             Err := True;
  1073.         end;
  1074.         if (not ((Value >= LowLim) and (Value <= UpLim))) then
  1075.             Beep;
  1076.     until (Value >= LowLim) and (Value <= UpLim) and (not (Err));
  1077.     Param := Value;
  1078.     GetReal := BC;
  1079. end;
  1080.  
  1081. function GetString(var Param: string; Len, X, Y: byte): char;
  1082.  
  1083. var
  1084.     Temp: string;
  1085.     BC: char;
  1086.  
  1087. begin
  1088.     Temp := Param;
  1089.     Temp := Input(Temp, [#32..#126], Len, X, Y, BC);
  1090.     Param := Temp;
  1091.     GetString := BC;
  1092. end;
  1093.  
  1094. function GetWord(var Param: word; LowLim, UpLim: word; Len, X, Y: byte): char;
  1095.  
  1096. var
  1097.     BC: char;
  1098.     WW, WL, WH: longint;
  1099.  
  1100. begin
  1101.     WW := longint(Param);
  1102.     WL := longint(LowLim);
  1103.     WH := longint(UpLim);
  1104.     BC := GetLongInt(WW, WL, WH, Len, X, Y);
  1105.     Param := word(WW);
  1106.     GetWord := BC;
  1107. end;
  1108.  
  1109. procedure DBF.GoBottom;
  1110. Var KeyStr : String;
  1111. begin
  1112.     If CurrNdx <> 0 then
  1113.     begin
  1114.       ClearKey(Indexes^[CurrNdx].Ndx);
  1115.       PrevKey(Indexes^[CurrNdx].Ndx, DBRecNum, KeyStr);
  1116.       GetDBRec(DBRecNum);
  1117.     end
  1118.     else
  1119.       GetDBRec(Header^.RecCount);
  1120. end;
  1121.  
  1122. procedure DBF.GoTop;
  1123. Var KeyStr : String;
  1124. begin
  1125.     If CurrNdx <> 0 then
  1126.     begin
  1127.       ClearKey(Indexes^[CurrNdx].Ndx);
  1128.       NextKey(Indexes^[CurrNdx].Ndx, DBRecNum, KeyStr);
  1129.       GetDBRec(DBRecNum);
  1130.     end
  1131.     else
  1132.       GetDBRec(1);
  1133. end;
  1134.  
  1135. function DBF.IIF(BoolVAR: boolean; IfTRUE, IfFALSE: string): string;
  1136.  
  1137. begin
  1138.     if BoolVAR then
  1139.         IIF := IfTRUE
  1140.     else
  1141.         IIF := IfFALSE;
  1142. end;
  1143.  
  1144. function DBF.IndsAreOpen: boolean;
  1145.  
  1146. var
  1147.     J: byte;
  1148.  
  1149. begin
  1150.     IndsAreOpen := False;
  1151.     for J := 1 to MaxInds do
  1152.         if Indexes^[J].Open then begin
  1153.             IndsAreOpen := True;
  1154.             Exit;
  1155.         end;
  1156. end;
  1157.  
  1158. procedure DBF.IndexOn(NdxID: byte; NdxName: FileName; NdxField: byte; DupFlag: byte);
  1159.  
  1160. var
  1161.     RecNumber: longint;
  1162.  
  1163. begin
  1164.     MakeDBIndex(NdxID, NdxName, Fields^[NdxField].FieldLen, DupFlag);
  1165.     OpenDBIndex(NdxID, NdxName, Fields^[NdxField].FieldLen, DupFlag);
  1166.     for RecNumber := 1 to TotalRecs do begin
  1167.         GetDBRec(RecNumber);
  1168.         if not Deleted then
  1169.         AddDBKey(NdxID, Field(NdxField));
  1170.     end;
  1171. end;
  1172.  
  1173. constructor DBF.Init(DBName: FileName);
  1174.  
  1175. var
  1176.     NdxID: byte;
  1177.  
  1178. begin
  1179.     Inc(FilesOpen);
  1180.     New(Header);
  1181.     New(Fields);
  1182.     New(Indexes);
  1183.     DBFName := RTrim(LTrim(DBName));
  1184.     Assign(DBFile, DBFName);                                {$I-}
  1185.     Reset(DBFile, 1);                                       {$I+}
  1186.     TPDBErr := IOResult;
  1187.     if (TPDBErr <> 0) and (not GotOne) then begin
  1188.         TErrorName := DBName;
  1189.         BailOut;
  1190.     end;
  1191.     DBFOpen := True;
  1192.     DBRecNum := 1;
  1193.     for NdxID := 1 to MaxInds do begin
  1194.         Indexes^[NdxID].NdxName := '';
  1195.         Indexes^[NdxID].Open := False;
  1196.         Indexes^[NdxID].NdxID := 0;
  1197.     end;
  1198.     CurrNdx := 0;
  1199.     ReadDBHeader;
  1200.     GetMem(DBRecord,Header^.RecordLen);
  1201. end;
  1202.  
  1203.  
  1204. function Input(var S: string; Term: CharSet; L, X, Y: byte; var BC: char): string;
  1205.  
  1206. const
  1207.     Next: CharSet = [Return, CursorUp, CursorDown, PageUp, PageDown, Escape];
  1208.  
  1209. var
  1210.     P: byte;
  1211.     Ch: char;
  1212.     Temp: string;
  1213.  
  1214. begin
  1215.     CursorOn;
  1216.     if S = '0' then
  1217.         S[0] := #0;
  1218.     Temp := Replicate(Filler, L - Length(S));
  1219.     Temp := Concat(S, Temp);
  1220.     Flash(Y, X, Reverse, Temp);
  1221.     P := 0;
  1222.     repeat
  1223.         GotoXY(X + P, Y);
  1224.         Ch := ReadChar;
  1225.         if UpperCase then
  1226.             CH := UpCase(CH);
  1227.         if (CH in Term) then begin
  1228.             if P < L then begin
  1229.                 if Length(S) = L then
  1230.                     Delete(S, L, 1);
  1231.                 Inc(P);
  1232.                 Insert(CH, S, P);
  1233.                 Write(Copy(S, P, L));
  1234.                 if AutoWrap and (P = L) then
  1235.                     Ch := Return;
  1236.             end else if not (AutoWrap) then
  1237.                 Beep;
  1238.         end else
  1239.             case CH of
  1240.                 ^H, #127: if P > 0 then begin
  1241.                     Delete(S, P, 1);
  1242.                     Write(^H, Copy(S, P, L), Filler);
  1243.                     Dec(P);
  1244.                 end else
  1245.                     Beep;
  1246.                 DelKey: if P < Length(S) then begin
  1247.                     Delete(S, Succ(P), 1);
  1248.                     Write(Copy(S, Succ(P), L), Filler);
  1249.                 end;
  1250.                 CursorLeft: if P > 0 then
  1251.                     Dec(P)
  1252.                 else
  1253.                     Beep;
  1254.                 CursorRight: if P < Length(S) then
  1255.                     Inc(P)
  1256.                 else
  1257.                     Beep;
  1258.                 CursorHome: P := 0;
  1259.                 CursorEND: P := Length(S);
  1260.                 ^Y: begin
  1261.                     Write(Replicate(Filler, Length(S) - P));
  1262.                     Delete(S, Succ(P), L);
  1263.                 end;
  1264.             end;
  1265.     until CH in Next;
  1266.     P := Length(S);
  1267.     Input := S;
  1268.     BC := CH;
  1269.     CursorOff;
  1270. end;
  1271.  
  1272.  
  1273. function IntToStr(Number: longint): string;
  1274.  
  1275. var
  1276.     Temp: string;
  1277.  
  1278. begin
  1279.     Str(Number, Temp);
  1280.     IntToStr := RTrim(LTrim(Temp));
  1281. end;
  1282.  
  1283. function DBF.Locate(FieldNo: byte; SearchStr: string): boolean;
  1284.  
  1285. var
  1286.     RecNumber: longint;
  1287.  
  1288. begin
  1289.     DBReset;
  1290.     RecNumber := 1;
  1291.     while RecNumber <= TotalRecs do begin
  1292.         GetDBRec(RecNumber);
  1293.         if Pos(SearchStr, IIF(UCKey, Upper(Field(FieldNo)), Field(FieldNo))) > 0 then begin
  1294.             Locate := True;
  1295.             Exit;
  1296.         end;
  1297.         RecNumber := RecNumber + 1;
  1298.     end;
  1299.     Locate := False;
  1300. end;
  1301.  
  1302.  
  1303. procedure DBF.LookUp(SearchStr: string; NdxID: byte);
  1304.  
  1305. begin
  1306.     SearchKey(Indexes^[NdxID].Ndx, DBRecNum, SearchStr);
  1307.     if OK then begin
  1308.         GetDBRec(DBRecNum);
  1309.         Found := True;
  1310.     end else
  1311.         Found := False;
  1312. end;
  1313.  
  1314. procedure DBF.MakeDBIndex(NdxID: byte; DBIndexName: FileName; KeyLen, Status: integer);
  1315.  
  1316. begin
  1317.     MakeIndex(Indexes^[NdxID].Ndx, DBIndexName, KeyLen, Status);
  1318.     Indexes^[NdxID].NdxName := DBIndexName;
  1319.     Indexes^[NdxID].NdxID := NdxID;
  1320.     Indexes^[NdxID].Open := True;
  1321.     CloseDBIndex(NdxID);
  1322. end;
  1323.  
  1324. procedure DBF.Mark;
  1325.  
  1326. begin
  1327.     Mem[Seg(DBRecord^):Ofs(DBRecord^)+1] := $2A;
  1328. end;                                                        {Mark}
  1329.  
  1330. function Max(N1, N2: integer): integer;
  1331.  
  1332. begin
  1333.     if N1 > N2 then
  1334.         Max := N1
  1335.     else
  1336.         Max := N2;
  1337. end;                                                        {Max}
  1338.  
  1339. function Min(N1, N2: integer): integer;
  1340.  
  1341. begin
  1342.     if N1 < N2 then
  1343.         Min := N1
  1344.     else
  1345.         Min := N2;
  1346. end;                                                        {Min}
  1347.  
  1348. function DBF.Mul(Field1, Field2: byte): string;             (* Multiply field 1 and field2 *)
  1349.  
  1350. var
  1351.     T1, T2, T3: string;
  1352.     M1, M2, M3: real;
  1353.     ErrCode: integer;
  1354.  
  1355. begin
  1356.     T1 := RTrim(Field(Field1));
  1357.     T2 := RTrim(Field(Field2));
  1358.     Val(T1, M1, ErrCode);
  1359.     Val(T2, M2, ErrCode);
  1360.     M3 := M1 * M2;
  1361.     Str(M3: Max(Fields^[Field1].FieldLen, Fields^[Field2].FieldLen): Max(Fields^[Field1].FieldDec, Fields^[Field2].FieldDec),
  1362.             T3);
  1363.     Mul := LTrim(T3);
  1364. end;                                                        {Mul}
  1365.  
  1366. procedure DBF.NewDBRec;
  1367.  
  1368. begin
  1369.     if not Allocated then begin
  1370.         GetMem(DBRecord,Header^.RecordLen)
  1371.     end else begin
  1372.         FreeMem(DBRecord,Header^.RecordLen);
  1373.         DBRecord := nil;
  1374.         GetMem(DBRecord,Header^.RecordLen);
  1375.     end;
  1376.     FillChar(DBRecord^, Header^.RecordLen, #32);
  1377.     DBRecNum := TotalRecs + 1;
  1378. end;                                                        {NewDBRec}
  1379.  
  1380. procedure DBF.NextDBKey(NdxID: byte; KeyStr: DBKey);
  1381.  
  1382. begin
  1383.     if UCKey then
  1384.         KeyStr := Upper(KeyStr);
  1385.     NextKey(Indexes^[NdxID].Ndx, DBRecNum, KeyStr);
  1386.     GetDBRec(DBRecNum);
  1387. end;                                                        {NextDBKey}
  1388.  
  1389. procedure DBF.NextRec;
  1390.  
  1391. begin
  1392.     GetDBRec(DBRecNum + 1);
  1393. end;                                                        {NextRec}
  1394.  
  1395.  
  1396. procedure DBF.OpenDBIndex(NdxID: byte; DBIndexName: FileName; KeyLen, Status: integer);
  1397.  
  1398. begin
  1399.     OpenIndex(Indexes^[NdxID].Ndx, DBIndexName, KeyLen, Status);
  1400.     Indexes^[NdxId].NdxName := DBIndexName;
  1401.     Indexes^[NdxID].NdxID := NdxId;
  1402.     Indexes^[NdxID].Open := True;
  1403.     Inc(FilesOpen);
  1404.     SetIndexTo(NdxID);
  1405. end;                                                        {OpenDBIndex}
  1406.  
  1407. procedure DBF.Pack;
  1408.  
  1409. var
  1410.     FNo: byte;
  1411.     J, TRec: longint;
  1412.  
  1413. begin
  1414.     MAlloc := True;
  1415.     Done;
  1416.     Malloc := False;
  1417.     FromPack := True;
  1418.     DBReset;
  1419.     ReadDBHeader;
  1420.     TRec := 1;
  1421.     for J := 1 to TotalRecs do begin
  1422.         GetDBRec(J);
  1423.         if not Deleted then
  1424.         begin
  1425.             PutDBRec(TRec);
  1426.             TRec := TRec + 1;
  1427.         end;
  1428.     end;
  1429.     Done;
  1430.     Init(DBFName);
  1431.     TotalRecs := TRec - 1;
  1432.     WriteDBHeader;
  1433. end;                                                        {Pack}
  1434.  
  1435. procedure DBF.PrevDBKey(NdxID: byte; KeyStr: DBKey);
  1436.  
  1437. begin
  1438.     if UCKey then
  1439.         KeyStr := Upper(KeyStr);
  1440.     PrevKey(Indexes^[NdxID].Ndx, DBRecNum, KeyStr);
  1441.     GetDBRec(DBRecNum);
  1442. end;                                                        {PrevDBKey}
  1443.  
  1444. procedure DBF.PrevRec;
  1445.  
  1446. begin
  1447.     GetDBRec(DBRecNum - 1);
  1448. end;                                                        {PrevRec}
  1449.  
  1450. procedure Prompt(Row, Col: byte; PromptStr: Str80);
  1451.  
  1452. begin
  1453.     Flash(Row, Col, Normal, PromptStr);
  1454. end;                                                        {Prompt}
  1455.  
  1456. procedure DBF.PutDBRec(RecordNumber: longint);
  1457.  
  1458. begin
  1459.     DBRecNum := RecordNumber;
  1460.     RecordNumber := (RecordNumber - 1) * Header^.RecordLen + Header^.Location;
  1461.     Seek(DBFile, RecordNumber);
  1462.     BlockWrite(DBFile, DBRecord^, Header^.RecordLen, ErrCode);
  1463.     FreeMem(DBRecord,Header^.RecordLen);
  1464.     DBRecord := nil;
  1465. end;                                                        {PutDBRec}
  1466.  
  1467. function ReadChar: char;
  1468.  
  1469. var
  1470.     CH: char;
  1471.  
  1472. begin
  1473.     ReadKb(ExtKey, CH);
  1474.     if ExtKey then begin
  1475.         case CH of
  1476.             #75: CH := CursorLeft;
  1477.             #77: CH := CursorRight;
  1478.             #72: CH := CursorUp;
  1479.             #80: CH := CursorDown;
  1480.             #73: CH := PageUp;
  1481.             #81: CH := PageDown;
  1482.             #71: CH := CursorHome;
  1483.             #79: CH := CursorEND;
  1484.             #83: CH := DelKey;
  1485.             else CH := #0;
  1486.         end;
  1487.         if CH = #9 then
  1488.             CH := TabKey;
  1489.     end;
  1490.     ReadChar := CH;
  1491. end;                                                        {ReadChar}
  1492.  
  1493. procedure DBF.ReadDBHeader;
  1494. (*Read a .DBF header.*)
  1495.  
  1496. var
  1497.     FNo: byte;
  1498.     FAddr: longint;
  1499.  
  1500. begin
  1501.     BlockRead(DBFile, Header^, 32, ErrCode);
  1502.     TotalRecs := Header^.RecCount;
  1503.     NumFields := (Header^.Location - 33) div 32;
  1504.     FAddr := 1;
  1505.     for FNo := 1 to NumFields do begin
  1506.         BlockRead(DBFile, Fields^[FNo], 32, ErrCode);
  1507.         Fields^[FNo].FieldAddress := FAddr;
  1508.         FAddr := FAddr + Fields^[FNo].FieldLen;
  1509.     end;
  1510. end;                                                        (*ReadDBHeader*)
  1511.  
  1512. procedure ReadKB(var ExtKey: boolean; var Ch: char);
  1513.  
  1514. begin
  1515.     ExtKey := False;
  1516.     Ch := ReadKey;
  1517.     if Ch = #0 then begin
  1518.         ExtKey := True;
  1519.         Ch := ReadKey;
  1520.     end;
  1521. end;                                                        {ReadKB}
  1522.  
  1523. function RealToStr(Number: real): string;
  1524.  
  1525. var
  1526.     Temp: string;
  1527.     I: word;
  1528.  
  1529. begin
  1530.     Str(Number: NumLen: Decimals, Temp);
  1531.     Temp := LTrim(Temp);
  1532.     I := Length(Temp);
  1533.     while Temp[I] = '0' do
  1534.         Dec(I);
  1535.     if Temp[I] = '.' then
  1536.         Dec(I);
  1537.     RealToStr := Copy(Temp, 1, I);
  1538. end;                                                        {RealToStr}
  1539.  
  1540.  
  1541. procedure DBF.Recall;
  1542.  
  1543. begin
  1544.     Mem[Seg(DBRecord^):Ofs(DBRecord^)+1] := $20;
  1545. end;                                                        {Recall}
  1546.  
  1547. function DBF.RecCount: longint;
  1548.  
  1549. begin
  1550.     RecCount := TotalRecs;
  1551. end;
  1552.  
  1553. function DBF.RecNo: longint;
  1554.  
  1555. begin
  1556.     RecNo := DBRecNum;
  1557. end;
  1558.  
  1559. procedure DBF.Repl(FNo: Byte; InStr: string);
  1560. var
  1561.     Temp: string;
  1562. begin
  1563.     Temp := PadR(InStr, Fields^[FNo].FieldLen);
  1564.     Move(Temp[1], Mem[Seg(DBRecord^): Ofs(DBRecord^) + Fields^[FNo].FieldAddress], Fields^[FNo].FieldLen);
  1565. end;                                                   {Repl}
  1566.  
  1567. procedure DBF.ReplEach(FNo: byte; InStr: string);
  1568.  
  1569. var
  1570.     J: longint;
  1571.  
  1572. begin
  1573.     DBReset;
  1574.     for J := 1 to TotalRecs do begin
  1575.         GetDBrec(J);
  1576.         Repl(FNo, InStr);
  1577.         PutDBRec(J);
  1578.     end;
  1579. end;                                                        {ReplEach}
  1580.  
  1581.  
  1582. procedure DBF.Save;
  1583.  
  1584. begin
  1585.     PutDBRec(DBRecNum);
  1586. end;                                                        {Save}
  1587.  
  1588.  
  1589. procedure DBF.Say(FNo, Row, Col: byte);
  1590.  
  1591. var
  1592.     GG: integer;
  1593.     TempStr: string;
  1594.     Bool: char;
  1595.     TempDate: string [8];
  1596.     Month, Day, Year: string [2];
  1597.     YY: integer;
  1598.     MM, DD: byte;
  1599.     Slush: string [8];
  1600.  
  1601. begin
  1602.     case Chr(Ord(Fields^[FNo].FieldType)) of
  1603.         'C', 'N': begin
  1604.             TempStr := '';
  1605.             for GG := Fields^[FNo].FieldAddress to Fields^[FNo].FieldAddress+Fields^[FNo].FieldLen-1 do
  1606.                 TempStr := TempStr + Chr(Mem[Seg(DBRecord^):Ofs(DBRecord^)+GG]);
  1607.             Flash(Row, Col, Normal, TempStr);
  1608.         end;
  1609.         'L': begin
  1610.             Bool := Chr(Mem[Seg(DBRecord^):Ofs(DBRecord^)+Fields^[FNo].FieldAddress]);
  1611.             Flash(Row, Col, Normal, Bool);
  1612.         end;
  1613.         'D': begin
  1614.             TempDate := '';
  1615.             Slush := '';
  1616.             case DateFormat of
  1617.                 American: begin
  1618.                     Slush := Field(FNo);
  1619.                     TempDate := Copy(Slush, 5, 2) + '/' + Copy(Slush, 7, 2) + '/' + Copy(Slush, 3, 2);
  1620.                 end;
  1621.                 Ansi: begin
  1622.                     Slush := Field(FNo);
  1623.                     TempDate := Copy(Slush, 3, 2) + '.' + Copy(Slush, 5, 2) + '.' + Copy(Slush, 7, 2);
  1624.                 end;
  1625.                 British: begin
  1626.                     Slush := Field(FNo);
  1627.                     TempDate := Copy(Slush, 7, 2) + '/' + Copy(Slush, 5, 2) + '/' + Copy(Slush, 3, 2);
  1628.                 end;
  1629.                 French: begin
  1630.                     Slush := Field(FNo);
  1631.                     TempDate := Copy(Slush, 7, 2) + '/' + Copy(Slush, 5, 2) + '/' + Copy(Slush, 3, 2);
  1632.                 end;
  1633.                 German: begin
  1634.                     Slush := Field(FNo);
  1635.                     TempDate := Copy(Slush, 7, 2) + '.' + Copy(Slush, 5, 2) + '.' + Copy(Slush, 3, 2);
  1636.                 end;
  1637.                 Italian: begin
  1638.                     Slush := Field(FNo);
  1639.                     TempDate := Copy(Slush, 7, 2) + '-' + Copy(Slush, 5, 2) + '-' + Copy(Slush, 3, 2);
  1640.                 end;
  1641.             end;
  1642.             Flash(Row, Col, Normal, TempDate);
  1643.         end;
  1644.     end;
  1645. end;                                                        {Say}
  1646.  
  1647.  
  1648. procedure SetDateFormat(Format: byte);
  1649.  
  1650. begin
  1651.     DateFormat := Format;
  1652. end;
  1653.  
  1654.  
  1655. procedure SetDBColor(FG, BG: byte);
  1656.  
  1657. begin
  1658.     TextColor(FG);
  1659.     TextBackground(BG);
  1660. end;                                                        {SetDBColor}
  1661.  
  1662. procedure DBF.SetIndexTo(NdxID : Byte);
  1663. begin
  1664.    CurrNdx := NdxID;
  1665. end;
  1666.  
  1667. procedure DBF.ShowStatus;                                   {Display .DBF status.}
  1668.  
  1669. var
  1670.     FNo, K: byte;
  1671.  
  1672. begin
  1673.     ClrScr;
  1674.     Writeln('File name is ', Upper(DBFName), '.');
  1675.     Writeln('Last update was on ', Header^.Month, '/', Header^.Day, '/', Header^.Year, '.');
  1676.     Writeln('Number of records is ', Header^.RecCount, '.');
  1677.     Writeln('Data starts at byte # ', Header^.Location, '.');
  1678.     Writeln('Record length is ', Header^.RecordLen, ' bytes.');
  1679.     Writeln('There are ', NumFields, ' fields.');
  1680.     Wait;
  1681.     for FNo := 1 to NumFields do begin
  1682.         Write('Field # ', FNo: 2, ': ');
  1683.         for K := 1 to 11 do
  1684.             Write(Fields^[FNo].FieldName[K]);
  1685.         Write(' Type: ', Chr(Fields^[FNo].FieldType));
  1686.         Write('     Length: ', Fields^[FNo].FieldLen: 3);
  1687.         if Chr(Ord(Fields^[FNo].FieldType)) = 'N' then
  1688.             Write('     Decimals: ', Fields^[FNo].FieldDec: 2);
  1689.         Writeln;
  1690.         if FNo mod 20 = 0 then
  1691.             Wait;
  1692.     end;
  1693.     Wait;
  1694.     DBReset;
  1695. end;                                                        {ShowStatus}
  1696.  
  1697. procedure DBF.Skip(NumRecs : Longint);
  1698. Var KeyStr : String;
  1699.     N : Longint;
  1700. begin
  1701.     If CurrNdx <> 0 then
  1702.     begin
  1703.       If NumRecs = 1 then
  1704.       begin
  1705.          NextKey(Indexes^[CurrNdx].Ndx, DBRecNum, KeyStr);
  1706.          If not OK then Exit;
  1707.          GetDBRec(DBRecNum);
  1708.       end;
  1709.       If NumRecs > 1 then
  1710.       begin
  1711.          For N := DBRecNum to DBRecNum + NumRecs do
  1712.          begin
  1713.             NextKey(Indexes^[CurrNdx].Ndx, DBRecNum, KeyStr);
  1714.             If not OK then Exit;
  1715.          end;
  1716.          GetDBRec(DBRecNum);
  1717.       end;
  1718.       If NumRecs < 0 then
  1719.       begin
  1720.          For N := DBRecNum downto (DBRecNum + NumRecs - 1) do
  1721.          begin
  1722.             PrevKey(Indexes^[CurrNdx].Ndx, DBRecNum, KeyStr);
  1723.             If not OK Then Exit;
  1724.          end;
  1725.          GetDBRec(DBRecNum);
  1726.       end;
  1727.     end
  1728.     else
  1729.     begin
  1730.          GetDBRec(DBRecNum + NumRecs);
  1731.     end;
  1732. end;                                                        {Skip}
  1733.  
  1734.  
  1735. function DBF.Sub(Field1, Field2: byte): string;             (* Subtract field 2 FROM field 1 *)
  1736.  
  1737. var
  1738.     T1, T2, T3: string;
  1739.     S1, S2, S3: real;
  1740.     ErrCode: integer;
  1741.  
  1742. begin
  1743.     T1 := RTrim(Field(Field1));
  1744.     T2 := RTrim(Field(Field2));
  1745.     Val(T1, S1, ErrCode);
  1746.     Val(T2, S2, ErrCode);
  1747.     S3 := S1 - S2;
  1748.     Str(S3: Max(Fields^[Field1].FieldLen, Fields^[Field2].FieldLen): Max(Fields^[Field1].FieldDec, Fields^[Field2].FieldDec),
  1749.             T3);
  1750.     Sub := LTrim(T3);
  1751. end;                                                        {Sub}
  1752.  
  1753. function DBF.Sum(FNo: byte): real;
  1754. {Sums a numeric field.  If specified field is not numeric returns 0.}
  1755.  
  1756. var
  1757.     J: longint;
  1758.     TempStr: string;
  1759.     TempReal: real;
  1760.     EC: integer;
  1761.     TotalSum: real;
  1762.  
  1763. begin
  1764.     if Chr(Ord(Fields^[FNo].FieldType)) <> 'N' then begin
  1765.         Sum := 0;
  1766.         Exit;
  1767.     end else begin
  1768.         DBReset;
  1769.         TotalSum := 0;
  1770.         for J := 1 to TotalRecs do begin
  1771.             GetDBRec(J);
  1772.             TempStr := RTrim(LTrim(Field(FNo)));
  1773.             Val(TempStr, TempReal, EC);
  1774.             TotalSum := TotalSum + TempReal;
  1775.         end;
  1776.     end;
  1777.     Sum := TotalSum;
  1778. end;                                                        {Sum}
  1779.  
  1780. procedure Wait;
  1781.  
  1782. begin
  1783.     Writeln('Press any key to continue...');
  1784.     Ch := ReadKey;
  1785. end;                                                        {Wait}
  1786.  
  1787.  
  1788. procedure DBF.WriteDBHeader;
  1789. {Update .DBF header.}
  1790.  
  1791. begin
  1792.     DBReset;
  1793.     GetDate(Y, M, D, DW);
  1794.     Y := Y - 1900;
  1795.     Header^.Year := Y;
  1796.     Header^.Month := M;
  1797.     Header^.Day := D;
  1798.     Header^.RecCount := TotalRecs;
  1799.     BlockWrite(DBFile, Header^, 32, ErrCode);
  1800. end;                                                        {WriteDBHeader}
  1801.  
  1802. procedure DBF.Zap;
  1803.  
  1804. var
  1805.     FNo: byte;
  1806.  
  1807. begin
  1808.     Rewrite(DBFile, 1);
  1809.     TotalRecs := 0;
  1810.     Header^.RecCount := 0;
  1811.     BlockWrite(DBFile, Header^, 32, ErrCode);
  1812.     for FNo := 1 to NumFields do begin
  1813.         BlockWrite(DBFile, Fields^[FNo], 32, ErrCode);
  1814.     end;
  1815.     Header^.Terminator := Chr(Ord($0D));
  1816.     BlockWrite(DBFile, Header^.Terminator, 1, ErrCode);
  1817.     DBReset;
  1818. end;                                                        {Zap}
  1819.  
  1820. begin                                                       {TPDB}
  1821.     SetDateFormat(American);
  1822.     FromPack := False;
  1823.     TAErrorProc := @DBF.BailOut;
  1824.     TErrorName := '';
  1825.     TPDBErr := 0;
  1826.     FilesOpen := 0;
  1827. end.                                                        {TPDB}
  1828.  
  1829. {END of Source Code - TPDB.pas Version 3.35  Copyright 1988 - 1992 Brian Corll }
  1830.  
  1831.